home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / scm / xscm.lha / xscm / xelk.scm < prev    next >
Encoding:
Text File  |  1992-08-29  |  3.1 KB  |  111 lines
  1. ;;; This module provides a rudimentary emulation of the Elk
  2. ;;; Motif environment, permitting some Elk applications to run
  3. ;;; under xmscm unchanged.
  4.  
  5. ;; Initialization
  6.  
  7. (load "x11")
  8. (load "xm")
  9.  
  10. (define (load-widgets . args) #t)    ; they're all pre-loaded
  11.  
  12. (define (application-initialize sym)
  13.   (let ((name (symbol->string sym)))
  14.     (if (defined? vs:top-level)
  15.     (xt:app-create-shell name name xt:application-shell
  16.                  (xt:display vs:top-level))
  17.     (xt:initialize name name))))
  18.  
  19. (define (create-managed-widget class parent)
  20.   (xt:create-managed-widget (xt:class-name class) class parent))
  21.  
  22. (define realize-widget xt:realize-widget)
  23.  
  24. (define (context-main-loop con)
  25.   (if (not (defined? vs:top-level))
  26.       (xt:main-loop)))
  27.  
  28. (define (context-add-timeout con when func)
  29.   (xt:add-time-out when func))
  30.  
  31. (define (remove-timeout t)
  32.   (xt:remove-time-out t))
  33.  
  34. (define (find-class class-name)
  35.   (case class-name
  36.     ((bulletin-board) xm:bulletin-board)
  37.     ((cascade-button) xm:cascade-button)
  38.     ((drawing-area) xm:drawing-area)
  39.     ((push-button) xm:push-button)
  40.     ((row-column) xm:row-column)
  41.     ((scroll-bar) xm:scroll-bar)
  42.     (else (error "invalid class name" class-name))))
  43.  
  44. (define (set-values! . argl)
  45.   (let ((widget (car argl)))
  46.     (let loop ((args (cdr argl)))
  47.       (let ((sym (car args))
  48.         (name (elkid->scmid (car args)))
  49.         (value (cadr args)))
  50.     (if (equal? value 'empty)
  51.         (set! value (make-string 0)))
  52.     (if (equal? sym 'label-string)
  53.         (begin
  54.           (if (symbol? value)
  55.           (set! value (symbol->string value)))
  56.           (set! value (xm:string-create value))))
  57.     (if (equal? sym 'alignment)
  58.         (set! value
  59.           (cond
  60.            ((string=? value "alignment_beginning")
  61.             xm:alignment-beginning)
  62.            ((string=? value "alignment_center")
  63.             xm:alignment-center)
  64.            ((string=? value "alignment_end")
  65.             xm:alignment-end))))
  66.     (if (equal? sym 'orientation)
  67.         (set! value
  68.           (case value
  69.             ((horizontal) xm:horizontal)
  70.             ((vertical) xm:vertical))))
  71.     (format #t "~s: ~s~%" name
  72.         (if (xm:xmstring? value)
  73.             (xm:string-get-first-segment value)
  74.             value))
  75.     (case sym
  76.       ((activate-callback arm-callback disarm-callback)
  77.        (xt:add-callback widget name (car value)))
  78.       (else    (xt:set-values widget name value)))
  79.     (set! args (cddr args))
  80.     (if (not (null? args))
  81.         (loop args))))))
  82.  
  83. (define (elkid->scmid sym)
  84.   (let ((pair
  85.      (assoc
  86.       sym
  87.       `(
  88.         (activate-callback    . ,xm:n-activate-callback)
  89.         (alignment        . ,xm:n-alignment)
  90.         (arm-callback    . ,xm:n-arm-callback)
  91.         (border-width    . ,xm:n-border-width)
  92.         (disarm-callback    . ,xm:n-disarm-callback)
  93.         (height        . ,xm:n-height)
  94.         (label-string    . ,xm:n-label-string)
  95.         (menu-bar        . ,xm:n-menu-bar)
  96.         (menu-help-widget    . ,xm:n-menu-help-widget)
  97.         (orientation    . ,xm:n-orientation)
  98.         (recompute-size    . ,xm:n-recompute-size)
  99.         (show-separator    . ,xm:n-show-separator)
  100.         (width        . ,xm:n-width)
  101.         (x            . ,xm:n-x)
  102.         (y            . ,xm:n-y)
  103.         ))))
  104.     (if (not pair)
  105.     (error "unmapped elk resource symbol" sym)
  106.     (cdr pair))))
  107.      
  108. (define (add-callback widget sym func)
  109.   (if func
  110.       (xt:add-callback widget (elkid->scmid sym) func)))
  111.